home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / ciarnv85.arc / UTIL.4TH < prev    next >
Text File  |  1986-04-08  |  3KB  |  98 lines
  1. ( UTIL.4TH     This is a set of utilities canned in FORTH.   )
  2.  
  3.  HEX
  4. : DI DECIMAL ;
  5.  
  6. ( C" causes the following string, terminated by " to be stored in FORTH )
  7. ( memory and pointed to by the word following the closing quote. E. G.  )
  8. ( C" b:file.4th" FPTR" )
  9. ( The above example creates a FORTH word, FPTR" which leaves the address )
  10. ( of the string "b:file.4th" on the stack. )
  11. : C" 22 WORD DUP DUP C@ 1+ + 0 SWAP C! DUP C@ 2+ ALLOT 1+ CONSTANT ;
  12.  
  13. : CTAG CR ==>FH 
  14.   IF ."   TAG " ==>FN ZTYPE ."  LINE# " BASE @ A BASE ! ==>L# @ . BASE ! 
  15.   THEN LATEST ID. ;
  16.  
  17. ( This word vectors PAGE to clear the screen using ANSI escape codes. )
  18. : <MPAGE> 1B EMIT ." [2J" ; ' <MPAGE> CFA 'PAGE !
  19.  
  20. : ?TERM 600 0 0 FF 21 INTCALL FF AND ; ( gets a char from keyboard )
  21. : ?KEY ?TERM ABORT" STOPPED. " ; ( checks for and aborts if any key hit )
  22.  
  23. ASSEMBLER DEFINITIONS
  24.  : IFB 73 C, 0 C, HERE RESET ;
  25.  : IFA 76 C, 0 C, HERE RESET ;
  26. FORTH DEFINITIONS
  27.  
  28. ( INVOKE THE DOS COMMAND PROCESSOR FOR THE GIVEN ZERO STRING )
  29. CODE DOSEXEC
  30. AX, CS     MOV
  31. ES, AX     MOV
  32. BX, # 1800 MOV
  33. AX, # 4A00 MOV
  34.            INT21 ( RELEASE ALL BUT 1800H PARAGRAPHS )
  35. AX, CS     MOV
  36. ES, AX     MOV
  37. BX         POP
  38. DX         POP
  39. AX, # 4B00 MOV
  40. SI         PUSH
  41. BP         PUSH
  42. 80 , SP    MOV
  43.            INT21
  44. AX, CS     MOV
  45. DS, AX     MOV
  46. SS, AX     MOV
  47. SP, 80     MOV
  48. BP         POP
  49. SI         POP
  50. NEXT       JMP END-CODE
  51.  
  52. CODE       DSEGMENT ( RETURNS FORTHS CODE SEGMENT ADDR )
  53. AX, DS     MOV
  54. AX         PUSH
  55. NEXT       JMP    END-CODE
  56.  
  57. CODE LCMOVE    BX, SI MOV   CX POP DI POP ES POP SI POP DS POP
  58.      REPZ BYTE MOVS  AX, CS MOV  DS, AX MOV  ES, AX MOV 
  59.      SI, BX MOV   NEXT JMP END-CODE
  60.  
  61. FORTH
  62.  
  63. C" COMMAND.COM" DOSCMD
  64.  
  65. ( The FORTH word DOS followed by any MS-DOS command will invoke that   )
  66. ( command. Afterwards, you are returned to FORTH. )
  67. : DOS 0 WORD DUP C@ 1+ OVER C! DUP C@ OVER + 0D SWAP C!
  68.       DUP DUP 3 + OVER C@ 1+ <CMOVE DUP C@ 2F03 + OVER ! 2043 OVER 2+ !
  69.       84 ! DSEGMENT 86 ! ( PARM LINE ADDR )
  70.       5C 88 ! DSEGMENT 8A ! ( FCB 1 )
  71.       6C 8C ! DSEGMENT 8E ! ( FCB 2 )
  72.       2C @ 82 ! ( ENVIRONMENT )
  73.       DOSCMD 82 DOSEXEC ;
  74.  
  75. ( The word FEMITO will open a file and vector the word EMIT so that   )
  76. ( anything that is emitted to the screen will also be written to that )
  77. ( file until the word FEMITC which closes the file opened by FEMITO. )
  78.  
  79. CREATE FHAND 0 , 
  80. VARIABLE 'FEMIT 
  81. CREATE CSUM 0 , 
  82.  
  83. : FEMIT FHAND @ OVER FPUTC 'FEMIT @ EXECUTE ;
  84. : FEMITO FHAND @ ABORT" : FEMITO    ALREADY OPEN "
  85.     1 FOPEN ?DUP ( FEMITO EXPECTS FILE NAME PTR )
  86.     IF FHAND ! 'EMIT @ 'FEMIT ! 
  87.      [ ' FEMIT CFA ] LITERAL 'EMIT !
  88.     ELSE 1 ABORT" FILE WONT OPEN  FEMITO "
  89.     THEN ;
  90. : FEMITC FHAND @ DUP 
  91.     IF DUP 1A FPUTC FCLOSE 'FEMIT @ 'EMIT ! 
  92.     ELSE DROP
  93.     THEN ;
  94. : FCREAT ( FNAME PMODE -- FPTR )  ( creates a file )
  95.     ( RETURNS 0 IF IT FAILS, IOERR HAS ERROR # )
  96.     0 ROT ROT 3C00 DCALL 
  97.     IF 0 ELSE 0 SWAP THEN IOERR ! ; 
  98.